home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The X-Philes (2nd Revision)
/
The X-Philes Number 1 (1995).iso
/
xphiles
/
hp48_2
/
star-1_0.tar
/
eval.c
< prev
next >
Wrap
C/C++ Source or Header
|
1991-03-22
|
28KB
|
1,467 lines
/* eval.c -- STAR Functions and Operators
This file is part of STAR, the Saturn Macro Assembler.
STAR is not distributed by the Free Software Foundation. Do not ask
them for a copy or how to obtain new releases. Instead, send e-mail to
the address below. STAR is merely covered by the GNU General Public
License.
Please send your comments, ideas, and bug reports to
Jan Brittenson <bson@ai.mit.edu>
*/
/* Copyright (C) 1990, 1991 Jan Brittenson.
STAR is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 1, or (at your option) any
later version.
STAR is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with STAR; see the file COPYING. If not, to obtain a copy, write
to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,
USA, or send e-mail to bson@ai.mit.edu. */
/*
* All the 'evxx' routines are called with a standard interface:
*
* OPX: struct val opx(cpp, term) opx = op term;
* char **cpp;
* struct val term;
*
* XOPY: struct val xopy(cpp, term1, term2)
* char **cpp;
* struct val term1, term2; xopy = term1 op term2;
*/
#include <stdio.h>
#include <math.h>
#include "star.h"
#include "literals.h"
#include "symbols.h"
/* External functions/data */
extern SYM_ROOT
*symtbl;
extern
errcnt, pass;
extern char
*str();
/* Global variables/data */
int noseq;
/* Make sure valid digit */
is_digit(c)
char c;
{
if(!isdigit(c))
{
sgnerr("Invalid number");
return(FALSE);
}
return(TRUE);
}
/* Compute current instance level of
* existing symbol.
*/
instances_sym(symp)
struct sstruct *symp;
{
int n;
register struct vnode *vp;
if(!symp)
return(0);
for(n = 1, vp = symp->vlink; vp; n++, vp = vp->vlink);
return(n);
}
/* Compute current instance level of
* symbol, return 0 if symbol does not exist.
*/
instances(name)
char *name;
{
return(instances_sym(sm_find_sym(symtbl, name)));
}
/* XOPY: Not equal */
struct val evbne(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
if(term1.type != term2.type)
return(val_one);
switch(term1.type)
{
case VT_INT: return(intval(term1.vint != term2.vint));
case VT_REAL: return(intval(term1.vdouble != term2.vdouble));
case VT_STR: return(intval(!scmp(term1.vstr, term2.vstr)));
case VT_SECT:
case VT_OP:
case VT_MAC: return(val_zero);
default:
fatal("`Not equal' operator applied to bogus type %d", term1.type);
}
}
/* OPX: Boolean not */
struct val evbnot(cpp, term)
char **cpp;
struct val term;
{
return(intval(!toint(term).vint));
}
/* OPX: Logical complement */
struct val evlnot(cpp, term)
char **cpp;
struct val term;
{
return(intval(~toint(term).vint));
}
/* OPX: Right mask */
struct val evrmask(cpp, term)
char **cpp;
struct val term;
{
return(intval((1 << toint(term).vint) - 1));
}
/* XOPY: Left shift */
struct val evlshf(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
term1.vint <<= term2.vint;
return(term1);
}
/* XOPY: Right shift */
struct val evrshf(cpp, term1, term2)
char **cpp;
struct val term1,term2;
{
term1 = toint(term1);
term2 = toint(term2);
term1.vint >>= term2.vint;
return(term1);
}
/* XOPY: Less than or equal */
struct val evble(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
if(term1.type != term2.type)
return(val_zero);
switch(term1.type)
{
case VT_INT: return(intval(term1.vint <= term2.vint));
case VT_REAL: return(intval(term1.vdouble <= term2.vdouble));
case VT_STR: return(intval(scmp(term1.vstr, term2.vstr) <= 0));
case VT_SECT:
case VT_OP:
case VT_MAC: return(val_zero);
default:
fatal("`Less than' operator applied to bogus type %d", term1.type);
}
}
/* XOPY: Greater than or equal */
struct val evbge(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
if(term1.type != term2.type)
return(val_zero);
switch(term1.type)
{
case VT_INT: return(intval(term1.vint >= term2.vint));
case VT_REAL: return(intval(term1.vdouble >= term2.vdouble));
case VT_STR: return(intval(scmp(term1.vstr, term2.vstr) >= 0));
case VT_OP:
case VT_SECT:
case VT_MAC: return(val_zero);
default:
fatal("`Greater than' operator applied to bogus type %d", term1.type);
}
}
/* XOPY: Less than */
struct val evblt(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
if(term1.type != term2.type)
return(val_zero);
switch(term1.type)
{
case VT_INT: return(intval(term1.vint < term2.vint));
case VT_REAL: return(intval(term1.vdouble < term2.vdouble));
case VT_STR: return(intval(scmp(term1.vstr, term2.vstr) < 0));
case VT_SECT:
case VT_OP:
case VT_MAC: return(val_zero);
default:
fatal("`Less than' operator applied to bogus type %d", term1.type);
}
}
/* XOPY: Greater than */
struct val evbgt(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
if(term1.type != term2.type)
return(val_zero);
switch(term1.type)
{
case VT_INT: return(intval(term1.vint > term2.vint));
case VT_REAL: return(intval(term1.vdouble > term2.vdouble));
case VT_STR: return(intval(scmp(term1.vstr, term2.vstr) > 0));
case VT_SECT:
case VT_OP:
case VT_MAC: return(val_zero);
default:
fatal("`Greater than' operator applied to bogus type %d", term1.type);
}
}
/* XOPY: Equal */
struct val evbeq(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
if(term1.type != term2.type)
return(val_zero);
switch(term1.type)
{
case VT_INT: return(intval(term1.vint == term2.vint));
case VT_REAL: return(intval(term1.vdouble == term2.vdouble));
case VT_STR: return(intval(!scmp(term1.vstr, term2.vstr)));
case VT_SECT:
case VT_OP:
case VT_MAC: return(val_zero);
default:
fatal("`Equal to' operator applied to bogus type %d", term1.type);
}
}
/* XOPY: Boolean or */
struct val evbor(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
if(term1.vint || term2.vint)
return(val_one);
return(val_zero);
}
/* XOPY: Boolean and */
struct val evband(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
if(term1.vint && term2.vint)
return(val_one);
return(val_zero);
}
/* XOPY: Bitwise or */
struct val evlor(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint | term2.vint));
}
/* XOPY: Bitwise and */
struct val evland(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint & term2.vint));
}
/* XOPY: Boolean xor */
struct val evbxor(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
if((!term1.vint && term2.vint) ||
(term1.vint && !term2.vint))
return(val_one);
return(val_zero);
}
/* XOPY: Bitwise xor */
struct val evlxor(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint ^ term2.vint));
}
/* XOPY: Add */
struct val evadd(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
extern char *expr_allp, *expr_strdup();
/* If either is double, make both double and return double result */
if(term1.type == VT_REAL || term2.type == VT_REAL)
{
term1 = toreal(term1);
term2 = toreal(term2);
return(realval(term1.vdouble + term2.vdouble));
}
if(term1.type == VT_STR && term2.type == VT_STR)
{
/* Reallocate strings, and discard intermediate NUL */
term1.vstr = expr_strdup(term1.vstr);
expr_allp--;
expr_strdup(term2.vstr);
return(term1);
}
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint + term2.vint));
}
/* XOPY: Subtract */
struct val evsub(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
/* If either is double, make both double and return double result */
if(term1.type == VT_REAL || term2.type == VT_REAL)
{
term1 = toreal(term1);
term2 = toreal(term2);
return(realval(term1.vdouble - term2.vdouble));
}
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint - term2.vint));
}
/* OPX: Unary minus */
struct val evneg(cpp, term)
char **cpp;
struct val term;
{
/* If term is double, make it double and return double result */
if(term.type == VT_REAL)
{
term = toreal(term);
return(realval(-term.vdouble));
}
return(intval(-toint(term).vint));
}
/* XOPY: Division */
struct val evdiv(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
/* If either is double, make the other double and return double result */
if(term1.type == VT_REAL || term2.type == VT_REAL)
{
term1 = toreal(term1);
term2 = toreal(term2);
return(realval(term1.vdouble / term2.vdouble));
}
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint / term2.vint));
}
/* XOPY: Multiplication */
struct val evmul(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
/* If either is double, make both double and return double result */
if(term1.type == VT_REAL || term2.type == VT_REAL)
{
term1 = toreal(term1);
term2 = toreal(term2);
return(realval(term1.vdouble * term2.vdouble));
}
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint * term2.vint));
}
/* XOPY: Modulo */
struct val evmod(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
/* If either is double, make both double and return double result */
if(term1.type == VT_REAL || term2.type == VT_REAL)
{
term1 = toreal(term1);
term2 = toreal(term2);
return(realval(fmod(term1.vdouble, term2.vdouble)));
}
term1 = toint(term1);
term2 = toint(term2);
return(intval(term1.vint % term2.vint));
}
/* OPX: Bit field */
struct val evbits(cpp)
char **cpp;
{
int tmp, tmpx;
tmp = 0;
noseq = TRUE;
for(;;)
{
/* Evaluate expression */
tmpx = toint(evexpr(cpp)).vint;
tmp |= (1 << tmpx);
/* Is there another entry in line? */
*cpp = byspace(*cpp);
if(**cpp != ',')
if(**cpp != ']')
{
sgnerr("Bad bit field element");
return(val_zero);
}
else /* End of field */
{
(*cpp)++;
return(intval(tmp));
}
/* Further arguments */
*cpp = byspace(++(*cpp));
}
}
/* OPX: Octal number conversion */
struct val evoct(cpp)
char **cpp;
{
INT tmp;
char *save = *cpp;
extern struct fstruct *fhit;
noseq = TRUE;
tmp = (INT) 0;
if(!isoct(**cpp))
{
/* Prefix "0" is a special case, which is correct */
if(!fhit->auxval)
sgnerr("Invalid octal constant");
return(val_zero);
}
/* Loop until no more digits */
while(isoct(**cpp))
{
tmp *= 8L;
tmp += **cpp - 48L;
(*cpp)++;
}
/* Dot or 'e' - then redo as real */
if(toupper(**cpp) == 'E' || **cpp == '.')
{
*cpp = save;
return(evreal(cpp));
}
return(intval(tmp));
}
/* OPX: Binary number conversion */
struct val evbin(cpp)
char **cpp;
{
INT tmp;
char *save = *cpp;
noseq = TRUE;
tmp = 0L;
is_digit(**cpp);
/* Loop until no more digits */
while(**cpp == '0' || **cpp == '1')
{
tmp += tmp;
tmp += **cpp - 48L;
(*cpp)++;
}
/* Dot or 'e' - then redo as real */
if(toupper(**cpp) == 'E' || **cpp == '.')
{
*cpp = save;
return(evreal(cpp));
}
return(intval(tmp));
}
/* OPX: Real number parsing */
struct val evreal(cpp)
char **cpp;
{
extern double strtod();
return(realval((REAL) strtod(*cpp, cpp)));
}
/* OPX: return local symbol value */
struct val evlocal(cpp)
char **cpp;
{
extern struct val local_value();
return(local_value((unsigned long) evdec(cpp).vint));
}
/* OPX: Decimal number conversion */
struct val evdec(cpp)
char **cpp;
{
INT tmp;
char *save = *cpp;
noseq = TRUE;
tmp = (INT) 0;
is_digit(**cpp);
/* Loop until no more digits */
while(isdigit(**cpp))
{
tmp *= 10L;
tmp += **cpp - 48L;
(*cpp)++;
}
/* Dot or 'e' - then redo as real */
if(toupper(**cpp) == 'E' || **cpp == '.')
{
*cpp = save;
return(evreal(cpp));
}
return(intval(tmp));
}
/* OPX: Hexadecimal number conversion */
struct val evhex(cpp)
char **cpp;
{
INT tmp;
char *save = *cpp;
tmp = (INT) 0;
noseq = TRUE;
if(!ishex(**cpp))
{
sgnerr("Invalid hex constant");
return(val_zero);
}
/* Loop until no more digits */
while(ishex(**cpp))
{
tmp *= 16L;
tmp += ((**cpp >= '0' && **cpp <= '9') ?
(**cpp - 48L) :
((**cpp & ~32L) - 55L));
(*cpp)++;
}
return(intval(tmp));
}
/* OPX: Opening parenthesis */
struct val evleft(cpp)
char **cpp;
{
struct val tmp;
/* Evaluate expression */
*cpp = byspace(*cpp);
tmp = evexpr(cpp);
mustbe(cpp, ')');
return(tmp);
}
/* Scan symbol in stream */
char *scansym(cpp, tmpcp)
char **cpp, *tmpcp;
{
char *cp;
/* Find first nonsymbol char */
for(cp = *cpp = byspace(*cpp); issym(**cpp); (*cpp)++);
/* Save and replace it with '\0' */
*tmpcp = **cpp;
**cpp = '\0';
if(!*cp)
sgnerr("Null symbol name");
return(cp);
}
/* OPX: Test if symbol is defined */
struct val evdefd(cpp)
char **cpp;
{
int tmpi;
char tmpc, *cp;
SYM_NODE *symp;
extern char *scansym();
/* Scan symbol and look it up */
*cpp = byspace(*cpp);
cp = scansym(cpp, &tmpc);
tmpi = (symp = sm_find_sym(symtbl, cp)) && !(symp->flags & F_UDF);
/* Restore delimiter and return */
cp[strlen(cp)] = tmpc;
return(intval(tmpi));
}
/* OPX: Return current location */
struct val evloc0()
{
return(intval(loc0));
}
/* OPX: Return current pass */
struct val evpass()
{
extern pass;
return(intval(pass));
}
/* OPX: Return running Kermit CRC */
struct val evkcrc()
{
extern unsigned long kcrc;
return(intval((INT) (kcrc & 0xffff)));
}
/* OPX: generate symbol */
struct val evgensym()
{
extern char *expr_strdup();
extern struct val strval();
char symname[64];
extern gensym_ctr;
sprintf(symname, "L_%05u", gensym_ctr++);
return(strval(expr_strdup(symname)));
}
/* OPX: return instance level of symbol */
struct val evinstances(cpp)
char **cpp;
{
char c, *name;
int i;
extern char *scansym();
name = scansym(cpp, &c);
i = instances(name);
name[strlen(name)] = c;
return(intval(i));
}
/* OPX: string */
struct val evstr(cpp)
char **cpp;
{
char *s;
struct val v;
(*cpp)--; /* Back up to quote */
v.type = VT_STR;
v.vstr = str(cpp);
return(v);
}
/* XOPY: return left portion of string */
struct val evleftstr(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = tostr(term1);
term2 = toint(term2);
if(term2.vint < 0 || term2.vint > strlen(term1.vstr))
return(term1);
term1.vstr[term2.vint] = '\0';
return(term1);
}
/* XOPY: return right portion of string */
struct val evrightstr(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
term1 = tostr(term1);
term2 = toint(term2);
if(term2.vint < 0 || term2.vint > strlen(term1.vstr))
return(term1);
term1.vstr += term2.vint - 1;
return(term1);
}
/* OPX: int to string by ascii value */
struct val evchartostr(cpp, term)
char **cpp;
struct val term;
{
char buf[2];
extern char *expr_strdup();
term = toint(term);
buf[1] = '\0';
buf[0] = term.vint;
term.vstr = expr_strdup(buf);
term.type = VT_STR;
return(term);
}
/* OPX string length */
struct val evstrlen(cpp, term)
char **cpp;
struct val term;
{
term = tostr(term);
term.vint = strlen(term.vstr);
term.type = VT_INT;
return(term);
}
/* OPX: trim leading spaces */
struct val evtrimld(cpp, term)
char **cpp;
struct val term;
{
term = tostr(term);
term.vstr = byspace(term.vstr);
return(term);
}
/* OPX: trim trailing spaces */
struct val evtrimtr(cpp, term)
char **cpp;
struct val term;
{
register char *cp;
term = tostr(term);
for(cp = term.vstr + strlen(term.vstr) - 1; cp >= term.vstr; cp--)
if((unsigned char) *cp > ' ')
{
*++cp = '\0';
return(term);
}
term.vstr[0] = '\0';
return(term);
}
/* OPX: eval */
struct val eveval(cpp, term)
char **cpp;
struct val term;
{
char *cp;
/* All types except strings evaluate to themselves */
if(term.type != VT_STR)
return(term);
cp = term.vstr;
return(evexpr(&cp));
}
/* OPX: uppercase conversion */
struct val evuc(cpp, term)
char **cpp;
struct val term;
{
extern struct val uppercase();
return(uppercase(term));
}
/* OPX: Recursive assembly.
* Should be recoded so it doesn't use goto's.
*/
struct val evinstr(cpp, term)
char **cpp;
struct val term;
{
char
*oldcodebuf, *oldcodeptr, *str, *tmp, tmpc, termc, *asnarg;
int
low, hi, center, old_codeblock = codeblock;
SYM_NODE *symp;
extern char
*malloc(), codebuf[], *codeptr;
extern struct istruct instbl[];
extern
hitlo[], hithi[], scmp(), symtop;
if(term.type != VT_STR)
return(toint(term));
if(codeptr > codebuf)
{
oldcodebuf = malloc(codeptr-codebuf);
bcopy(codebuf, oldcodebuf, codeptr-codebuf);
}
/* Block out code generation */
codeblock = TRUE;
oldcodeptr = codeptr;
codeptr = codebuf;
str = term.vstr;
/* Extract first word */
if(*(str = byspace(str)) == ';' || *str < '\040')
{
term = val_zero;
goto restore_ret;
}
for(tmp = str; *str > ' ' && (str == tmp || *str != '.') && *str != '=';
str++);
termc = *str;
*str = '\0';
tmpc = toupper(*tmp)-32;
/* Is it "name = expr"? */
if(termc && (termc == '=' || *byspace(str+1) == '='))
{
char defstr[132];
extern void ddef(), dorg();
extern struct val val_nullstr, localize();
static struct istruct
defs = {"=", ddef, 0, 0},
dorgs = {"=", dorg, 0, 0};
if(tmp[0] == '.' && !tmp[1])
{
sprintf(defstr, " %s", byspace(str + (termc == '=' ? 1 : 2)));
dorg(&dorgs, defstr);
}
else
{
sprintf(defstr, " %s %s", tmp,
byspace(str + (termc == '=' ? 1 : 2)));
ddef(&defs, defstr);
}
*str = termc;
term = localize(val_nullstr);
goto restore_ret;
}
/* Expand if macro */
if((symp = sm_find_sym(symtbl, tmp)) && symp->value.type == VT_MAC)
{
*str = termc;
expand_macro(symp->value.vmacro, byspace(str));
goto return_codebuf;
}
/* Look it up in the instruction table */
if((low = hitlo[tmpc]) >= 0 && low <= symtop)
for(hi = hithi[tmpc]; hi >= low;)
switch(scmp(tmp, instbl[center = (hi + low) >> 1].name))
{ /* Aim */
case -1: /* Hi */ hi = center-1; break;
case 1: /* Low */ low = center+1; break;
default: /* Eq */ goto found;
}
/* Not a macro or instruction */
sgnerr("Undefined instruction or macro - `%s'", tmp);
goto return_codebuf;
/* Instruction found */
found:
/* Restore string */
*str = termc;
/* Translate operands and generate code */
(*instbl[center].scandef)(&instbl[center], str);
return_codebuf:
/* Restore old codebuf and return new, low-endian */
term.type = VT_INT;
term.vint = 0;
while(codeptr-- > codebuf)
{
term.vint <<= 4;
term.vint |= (unsigned char) *codeptr;
}
restore_ret:
if(oldcodeptr > codebuf)
{
bcopy(oldcodebuf, codebuf, oldcodeptr-codebuf);
free(oldcodebuf);
}
codeblock = old_codeblock;
codeptr = oldcodeptr;
return(term);
}
/* OPX: Recursive assembly.
* Should be recoded so it doesn't use goto's.
*
* Same as evinstr(), but returns number of nibbles instead.
* The code here should be generalized with assemble_line() and
* expand_body() as well as evinstr().
*/
struct val evinstrlen(cpp, term)
char **cpp;
struct val term;
{
char
*oldcodebuf, *oldcodeptr, *str, *tmp, tmpc, termc, *asnarg;
int
low, hi, center, old_codeblock = codeblock;
SYM_NODE *symp;
extern char
*malloc(), codebuf[], *codeptr;
extern struct istruct
instbl[];
extern
hitlo[], hithi[], scmp(), symtop;
if(term.type != VT_STR)
return(toint(term));
if(codeptr > codebuf)
{
oldcodebuf = malloc(codeptr-codebuf);
bcopy(codebuf, oldcodebuf, codeptr-codebuf);
}
/* Block out code generation */
codeblock = TRUE;
oldcodeptr = codeptr;
codeptr = codebuf;
str = term.vstr;
/* Extract first word */
if(*(str = byspace(str)) == ';' || *str < '\040')
{
term = val_zero;
goto restore_ret;
}
for(tmp = str; *str > ' ' && (str == tmp || *str != '.') && *str != '=';
str++);
termc = *str;
*str = '\0';
tmpc = toupper(*tmp)-32;
/* Is it "name = expr"? */
if(termc && (termc == '=' || *byspace(str+1) == '='))
{
char defstr[132];
extern void ddef(), dorg();
extern struct val val_nullstr, localize();
static struct istruct
defs = {"=", ddef, 0, 0},
dorgs = {"=", dorg, 0, 0};
if(tmp[0] == '.' && !tmp[1])
{
sprintf(defstr, " %s", byspace(str + (termc == '=' ? 1 : 2)));
dorg(&dorgs, defstr);
}
else
{
sprintf(defstr, " %s %s", tmp,
byspace(str + (termc == '=' ? 1 : 2)));
ddef(&defs, defstr);
}
*str = termc;
term = localize(val_zero);
goto restore_ret;
}
/* Expand if macro */
if((symp = sm_find_sym(symtbl, tmp)) && symp->value.type == VT_MAC)
{
*str = termc;
expand_macro(symp->value.vmacro, byspace(str));
goto return_codebuf;
}
/* Look it up in the instruction table */
if((low = hitlo[tmpc]) >= 0 && low <= symtop)
for(hi = hithi[tmpc]; hi >= low;)
switch(scmp(tmp, instbl[center = (hi + low) >> 1].name))
{ /* Aim */
case -1: /* Hi */ hi = center-1; break;
case 1: /* Low */ low = center+1; break;
default: /* Eq */ goto found;
}
/* Not a macro or instruction */
sgnerr("Undefined instruction or macro - `%s'", tmp);
goto return_codebuf;
/* Instruction found */
found:
/* Restore string */
*str = termc;
/* Translate operands and generate code */
(*instbl[center].scandef)(&instbl[center], str);
return_codebuf:
/* Restore old codebuf and return new, low-endian */
term.type = VT_INT;
term.vint = 0;
term.vint = codeptr - codebuf;
restore_ret:
if(oldcodeptr > codebuf)
{
bcopy(oldcodebuf, codebuf, oldcodeptr-codebuf);
free(oldcodebuf);
}
codeptr = oldcodeptr;
return(term);
}
/* OPX: Return type */
struct val evtype(cpp, term)
char **cpp;
struct val term;
{
return(intval((INT) term.type));
}
/* XOPY: power */
struct val evpow(cpp, term1, term2)
char **cpp;
struct val term1, term2;
{
return(realval(pow((double) toreal(term1).vdouble,
(double) toreal(term2).vdouble)));
}
struct stdent {
double (*stdfun)(); /* Function */
int enabled; /* Enabled on this system */
}
ftable[] = {
{acos, TRUE}, {asin, TRUE},
{atan, TRUE}, {ceil, TRUE}, {cos, TRUE}, {cosh, TRUE},
{exp, TRUE}, {fabs, TRUE}, {floor, TRUE}, {fmod, TRUE},
{log, TRUE}, {log10, TRUE}, {sin, TRUE}, {sinh, TRUE},
{sqrt, TRUE}, {tan, TRUE}, {tanh, TRUE}};
/* OPX: standard functions */
struct val evfun(cpp, term)
char **cpp;
struct val term;
{
int nthfun;
extern struct fstruct *fhit;
extern struct val val_real0;
nthfun = fhit->auxval;
if(!ftable[nthfun].enabled)
{
sgnerr("Function `%s' not supported on this system", fhit->name);
return(val_real0);
}
#ifdef MSDOS
{
REAL ret1 = (*ftable[nthfun].stdfun)((double) toreal(term).vdouble);
return(realval(ret1));
}
#else
return(realval((REAL)
(*ftable[nthfun].stdfun)((double) toreal(term).vdouble)));
#endif
}
/* OPX: real to bin */
struct val evrtobin(cpp, term)
char **cpp;
struct val term;
{
struct val v;
INT i = 0;
int xs, digit;
term = toreal(term);
/* Sign nibble */
i = (v.vdouble < 0.0 ? 9 : 0);
xs = EXPONENT(v.vdouble);
/* Mantissa */
v.vdouble /= pow(10.0, (REAL) xs);
if(v.vdouble < 0.0)
v.vdouble = -v.vdouble;
for(digit = 0; digit < 12; digit++)
{
i <<= 4;
i += (INT) floor(v.vdouble = fmod(v.vdouble, 10.0));
v.vdouble *= 10.0;
}
/* Exponent */
i <<= 12;
if(xs >= 0)
i |= (xs & 0xfff);
else
{
int axs = -xs;
i |= (0x99a -
(((axs / 100) << 8) |
(((axs / 10) % 10) << 4) |
(axs % 10))) & 0xfff;
}
v.type = VT_INT;
v.vint = i;
return(v);
}
/* OPX: Pooled Literal */
struct val evliteral(cpp, term)
char **cpp;
struct val term;
{
char
*oldcodebuf, *oldcodeptr, *str, *tmp, tmpc, termc, *asnarg;
int
low, hi, center;
SYM_NODE *symp;
long
save_loc = loc, save_loc0 = loc0;
extern char
*malloc(), codebuf[], *codeptr;
extern struct istruct
instbl[];
extern
hitlo[], hithi[], scmp(), symtop, pass;
term = tostr(term);
if(codeptr > codebuf)
{
oldcodebuf = malloc(codeptr-codebuf);
bcopy(codebuf, oldcodebuf, codeptr-codebuf);
}
oldcodeptr = codeptr;
codeptr = codebuf;
str = term.vstr;
/* Extract first word */
if(*(str = byspace(str)) == ';' || *str < '\040')
{
term = val_zero;
goto restore_ret;
}
for(tmp = str; *str > ' ' && (str == tmp || *str != '.') && *str != '=';
str++);
termc = *str;
*str = '\0';
tmpc = toupper(*tmp)-32;
/* Is it "name = expr"? */
if(termc && (termc == '=' || *byspace(str+1) == '='))
{
sgnerr("Invalid literal");
term = intval(add_literal(codebuf, 0));
goto restore_ret;
}
/* Expand if macro */
if((symp = sm_find_sym(symtbl, tmp)) && symp->value.type == VT_MAC)
{
*str = termc;
expand_macro(symp->value.vmacro, byspace(str));
goto return_litaddr;
}
/* Look it up in the instruction table */
if((low = hitlo[tmpc]) >= 0 && low <= symtop)
for(hi = hithi[tmpc]; hi >= low;)
switch(scmp(tmp, instbl[center = (hi + low) >> 1].name))
{ /* Aim */
case -1: /* Hi */ hi = center-1; break;
case 1: /* Low */ low = center+1; break;
default: /* Eq */ goto found;
}
/* Not a macro or instruction */
sgnerr("Undefined instruction or macro - `%s'", tmp);
term = val_zero;
goto restore_ret;
/* Instruction found */
found:
/* Restore string */
*str = termc;
/* Translate operands and generate code */
(*instbl[center].scandef)(&instbl[center], str);
/* Add code to literal pool and return address */
return_litaddr:
loc0 = save_loc0;
loc = save_loc;
term.type = VT_INT;
term.vint = add_literal(codebuf, codeptr-codebuf);
/* Restore codebuf and return */
restore_ret:
loc0 = save_loc0;
loc = save_loc;
if(oldcodeptr > codebuf)
{
bcopy(oldcodebuf, codebuf, oldcodeptr-codebuf);
free(oldcodebuf);
}
codeptr = oldcodeptr;
return(term);
}
/* OPX: Test if symbol is LIBCALLed
*/
struct val evused(cpp)
char **cpp;
{
char *cp, tmpc;
SYM_NODE *tmps;
extern char *scansym();
/* Scan symbol and look it up */
*cpp = byspace(*cpp);
cp = scansym(cpp, &tmpc);
if(!(tmps = sm_find_sym(symtbl, cp)))
return(val_zero);
/* Return status */
return(intval((tmps->flags & F_USED) != 0));
}